home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / mouse.el.z / mouse.el
Encoding:
Text File  |  1998-05-21  |  53.8 KB  |  1,506 lines
  1. ;;; mouse.el --- window system-independent mouse support.
  2. ;; Keywords: hardware
  3.  
  4. ;; Copyright (C) 1988, 1992, 1993, 1994 Free Software Foundation, Inc.
  5. ;; Copyright (C) 1995 Tinker Systems
  6. ;; Copyright (C) 1995, 1996 Ben Wing.
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  22. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Synched up with: Not synched with FSF.  Almost completely divergent.
  26.  
  27. (provide 'mouse)
  28.  
  29. (global-set-key 'button1 'mouse-track)
  30. (global-set-key '(shift button1) 'mouse-track-adjust)
  31. (global-set-key '(control button1) 'mouse-track-insert)
  32. (global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
  33. (global-set-key '(meta button1) 'mouse-track-do-rectangle)
  34.  
  35. ;; enable drag regions (ograf@fga.de)
  36. ;; if button2 is dragged from within a region, this becomes a drop
  37. (if (or (featurep 'offix) ;; do we have DnD support?
  38.     (featurep 'cde))
  39.     (global-set-key 'button2 'mouse-drag-or-yank)
  40.   (global-set-key 'button2 'mouse-yank))
  41.  
  42. ;; enable drops from OffiX (ograf@fga.de)
  43. ;; accept any button1,2,3 drop with `mouse-offix-drop'
  44. (cond ((featurep 'offix)
  45.        (global-set-key 'drop1 'mouse-offix-drop)
  46.        (global-set-key 'drop2 'mouse-offix-drop)
  47.        (global-set-key 'drop3 'mouse-offix-drop)))
  48.  
  49. (defcustom mouse-track-rectangle-p nil
  50.   "*If true, then dragging out a region with the mouse selects rectangles
  51. instead of simple start/end regions."
  52.   :type 'boolean
  53.   :group 'mouse)
  54.  
  55. (defcustom mouse-yank-at-point nil
  56.   "*If non-nil, the function `mouse-yank' will yank text at the cursor location.
  57. Otherwise, the cursor will be moved to the location of the pointer click before
  58. text is inserted."
  59.   :type 'boolean
  60.   :group 'mouse)
  61.  
  62. (defvar mouse-yank-function 'mouse-consolidated-yank
  63.   "Function that is called upon by `mouse-yank' to actually insert text.")
  64.  
  65. (defun mouse-consolidated-yank ()
  66.   (interactive)
  67.   (case (device-type)
  68.     (x (x-yank-function))
  69.     (tty (yank))
  70.     (otherwise (yank))))
  71.  
  72.  
  73. (defun mouse-select ()
  74.   "Select Emacs window the mouse is on."
  75.   (interactive "@"))
  76.  
  77. (defun mouse-delete-window ()
  78.   "Delete the Emacs window the mouse is on."
  79.   (interactive "@")
  80.   (delete-window))
  81.  
  82. (defun mouse-keep-one-window ()
  83.   "Select Emacs window mouse is on, then kill all other Emacs windows."
  84.   (interactive "@")
  85.   (delete-other-windows))
  86.  
  87. (defun mouse-select-and-split ()
  88.   "Select Emacs window mouse is on, then split it vertically in half."
  89.   (interactive "@")
  90.   (split-window-vertically nil))
  91.  
  92. (defun mouse-set-point (event)
  93.   "Select Emacs window mouse is on, and move point to mouse position."
  94.   (interactive "@e")
  95.   (let ((window (event-window event))
  96.     (pos (event-point event))
  97.     (close-pos (event-closest-point event)))
  98.     (or window (error "not in a window"))
  99.     (select-window window)
  100.     (if (and pos (> pos 0))
  101.     ;; If the event was over a text char, it's easy.
  102.     (goto-char (max (min pos (point-max)) (point-min)))
  103.       (if (and close-pos (> close-pos 0))
  104.       (goto-char (max (min close-pos (point-max)) (point-min)))
  105.     ;; When the event occurs outside of the frame directly to the
  106.     ;; left or right of a modeline, close-point is nil, but
  107.     ;; event-over-modeline is also nil.  That will drop us to this
  108.     ;; point.  So instead of erroring, just return nil.
  109.     nil))))
  110.  
  111. (defun mouse-yank (event)
  112.   "Paste text with the mouse.
  113. If the variable `mouse-yank-at-point' is nil, then pasting occurs at the
  114. location of the click; otherwise, pasting occurs at the current cursor
  115. location."
  116.   (interactive "e")
  117.   (and (not mouse-yank-at-point)
  118.        (mouse-set-point event))
  119.   (funcall mouse-yank-function))
  120.  
  121. (defun click-inside-extent-p (click extent)
  122.   "Returns non-nil if the button event is within the bounds of the primary
  123. selection-extent, nil otherwise."
  124.   ;; stig@hackvan.com
  125.   (let ((ewin (event-window click))
  126.     (epnt (event-point click)))
  127.     (and ewin
  128.      epnt
  129.      extent
  130.      (eq (window-buffer ewin)
  131.          (extent-object extent))
  132.      (extent-start-position extent)
  133.      (> epnt (extent-start-position extent))
  134.      (> (extent-end-position extent) epnt))))
  135.  
  136. (defun click-inside-selection-p (click)
  137.   (or (click-inside-extent-p click primary-selection-extent)
  138.       (click-inside-extent-p click zmacs-region-extent)
  139.       ))
  140.  
  141. (defun point-inside-extent-p (extent)
  142.   "Returns non-nil if the point is within or just after the bounds of the
  143. primary selection-extent, nil otherwise."
  144.   ;; stig@hackvan.com
  145.   (and extent
  146.        (eq (current-buffer) 
  147.        (extent-object extent))
  148.        (> (point) (extent-start-position extent))
  149.        (>= (extent-end-position extent) (point))))
  150.  
  151. (defun point-inside-selection-p ()
  152.   ;; by Stig@hackvan.com
  153.   (or (point-inside-extent-p primary-selection-extent)
  154.       (point-inside-extent-p zmacs-region-extent)))
  155.  
  156. (defun mouse-drag-or-yank (event)
  157.   "Either drag or paste the current selection.  If the variable
  158.  `mouse-yank-at-point' is non-nil, then moves the cursor to the location of
  159.  the click before pasting.
  160.  This functions has to be improved. Until now it is just a (working) test."
  161.   ;; by Oliver Graf <ograf@fga.de>
  162.   (interactive "e")
  163.   (if (click-inside-extent-p event zmacs-region-extent)
  164.       ;; okay, this is a drag
  165.       (cond ((featurep 'offix)
  166.          (offix-start-drag-region event
  167.                       (extent-start-position zmacs-region-extent)
  168.                       (extent-end-position zmacs-region-extent)))
  169.         ((featurep 'cde)
  170.          ;; should also work with CDE
  171.          (cde-start-drag
  172.           (extent-start-position zmacs-region-extent)
  173.           (extent-end-position zmacs-region-extent)))
  174.         (t ding))
  175.     ;; no drag, call region-funct
  176.     (and (not mouse-yank-at-point)
  177.      (mouse-set-point event))
  178.     (funcall mouse-yank-function))
  179.   )
  180.  
  181. (defun mouse-offix-drop (event)
  182.   "Do something with an OffiX drop event. Inserts Text drops and
  183.  executes appropriate commands for specific drops.
  184.  Text drops follow the `mouse-yank-at-point' variable."
  185.   ;; by Oliver Graf <ograf@fga.de>
  186.   (interactive "e")
  187.   (let ((type (car (event-drag-and-drop-data event)))
  188.     (data (cadr (event-drag-and-drop-data event)))
  189.     (frame (event-channel event)))
  190.     (cond ((= type 2)
  191.        (let ((x pop-up-windows))
  192.          (setq pop-up-windows nil)
  193.          (pop-to-buffer (find-file-noselect data) nil frame)
  194.          (make-frame-visible frame)
  195.          (setq pop-up-windows x)))
  196.       ((= type 3)
  197.        (let ((x pop-up-windows))
  198.          (setq pop-up-windows nil)
  199.          (while (not (eq data ()))
  200.            (pop-to-buffer (find-file-noselect (car data)) nil frame)
  201.            (setq data (cdr data)))
  202.          (make-frame-visible frame)
  203.          (setq pop-up-windows x)))
  204.       ((= type 4)
  205.        (and (not mouse-yank-at-point)
  206.         (mouse-set-point event))
  207.        (insert data))
  208.       ((= type 5) (dired data))
  209.       ((or (= type 6) (= type 7)) (dired data)) ;; this is junk
  210.       ((= type 8) (funcall browse-url-browser-function data))
  211.       ((= type 9)
  212.        (let ((buf (generate-new-buffer "DndMIME")))
  213.          (set-buffer buf)
  214.          (pop-to-buffer buf nil frame)
  215.          (insert data)
  216.          (make-frame-visible frame)))
  217.       (t ;; this is raw data or unknown stuff
  218.        (let ((buf (generate-new-buffer "DndRawData")))
  219.          (set-buffer buf)
  220.          (pop-to-buffer buf nil frame)
  221.          (insert data)
  222.          (hexlify-buffer)
  223.          (make-frame-visible frame))))))
  224.  
  225. (defun mouse-eval-sexp (click force-window)
  226.   "Evaluate the sexp under the mouse.  Usually, this is the last sexp before
  227. the click, but if you click on a left paren, then it is the sexp beginning
  228. with the paren that is evaluated.  Also, since strings evaluate to themselves,
  229. they're fed to re-search-forward and the matched region is highlighted until
  230. the mouse button is released.
  231.  
  232. Perhaps the most useful thing about this function is that the evaluation of
  233. the expression which is clicked upon is relative not to the window where you
  234. click, but to the current window and the current position of point.  Thus,
  235. you can use `mouse-eval-sexp' to interactively test code that acts upon a
  236. buffer...something you cannot do with the standard `eval-last-sexp' function.
  237. It's also fantastic for debugging regular expressions."
  238.   ;; by Stig@hackvan.com
  239.   (interactive "e\nP")
  240.   (let (exp val result-str)
  241.     (setq exp (save-window-excursion
  242.         (save-excursion 
  243.           (mouse-set-point click)
  244.           (save-excursion
  245.             (or (looking-at "(") (forward-sexp -1))
  246.             (read (point-marker))))))
  247.     (cond ((stringp exp)
  248.        (if (setq val (re-search-forward exp nil t))
  249.            (let* ((oo (make-extent (match-beginning 0) (match-end 0))))
  250.          (set-extent-face oo 'highlight)
  251.          (set-extent-priority oo 1000)
  252.          ;; wait for button release...
  253.          (setq unread-command-event (next-command-event))
  254.          (delete-extent oo))
  255.          (message "Regex \"%s\" not found" exp)
  256.          (ding nil 'quiet)))
  257.       (t (setq val (if (fboundp 'eval-interactive)
  258.                (eval-interactive exp)
  259.              (eval exp)))))
  260.     (setq result-str (prin1-to-string val))
  261.     ;; #### -- need better test
  262.     (if (and (not force-window)
  263.          (<= (length result-str) (window-width (selected-window))))
  264.     (message "%s" result-str)
  265.       (with-output-to-temp-buffer "*Mouse-Eval*"
  266.     (condition-case nil
  267.         (pprint val)
  268.       (error (prin1 val))))
  269.       )))
  270.  
  271. (defun mouse-line-length (event)
  272.   "Print the length of the line indicated by the pointer."
  273.   (interactive "@e")
  274.   (save-excursion
  275.     (mouse-set-point event)
  276.     (message "Line length: %d" (- (progn (end-of-line) (point))
  277.                   (progn (beginning-of-line) (point)))))
  278.   (sleep-for 1))
  279.  
  280. (defun mouse-set-mark (event)
  281.   "Select Emacs window mouse is on, and set mark at mouse position.
  282. Display cursor at that position for a second."
  283.   (interactive "@e")
  284.   (let ((point-save (point)))
  285.     (unwind-protect
  286.     (progn (mouse-set-point event)
  287.            (push-mark nil t)
  288.            (sit-for 1))
  289.       (goto-char point-save))))
  290.  
  291. (defun mouse-scroll (event)
  292.   "Scroll point to the mouse position."
  293.   (interactive "@e")
  294.   (save-excursion
  295.     (mouse-set-point event)
  296.     (recenter 0)
  297.     (scroll-right (event-x event))))
  298.  
  299. (defun mouse-del-char (event)
  300.   "Delete the char pointed to by the mouse."
  301.   (interactive "@e")
  302.   (save-excursion
  303.     (mouse-set-point event)
  304.     (delete-char 1 nil)))
  305.  
  306. (defun mouse-kill-line (event)
  307.   "Kill the line pointed to by the mouse."
  308.   (interactive "@e")
  309.   (save-excursion
  310.     (mouse-set-point event)
  311.     (kill-line nil)))
  312.  
  313. (defun mouse-bury-buffer (event)
  314.   "Bury the buffer pointed to by the mouse, thus selecting the next one."
  315.   (interactive "e")
  316.   (save-selected-window
  317.     (select-window (event-window event))
  318.     (bury-buffer)))
  319.   
  320. (defun mouse-unbury-buffer (event)
  321.   "Unbury and select the most recently buried buffer."
  322.   (interactive "e")
  323.   (save-selected-window
  324.     (select-window (event-window event))
  325.     (let* ((bufs (buffer-list))
  326.        (entry (1- (length bufs)))
  327.        val)
  328.       (while (not (setq val (nth entry bufs)
  329.             val (and (/= (aref (buffer-name val) 0)
  330.                      ? )
  331.                  val)))
  332.     (setq entry (1- entry)))
  333.       (switch-to-buffer val))))
  334.  
  335. (defun narrow-window-to-region (m n)
  336.   "Narrow window to region between point and last mark"
  337.   (interactive "r")
  338.   (save-excursion
  339.     (save-restriction
  340.       (if (eq (selected-window) (next-window))
  341.       (split-window))
  342.       (goto-char m)
  343.       (recenter 0)
  344.       (if (eq (selected-window)
  345.           (if (zerop (minibuffer-depth))
  346.           (next-window)))
  347.       ()
  348.     (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
  349.  
  350. (defun mouse-window-to-region (event)
  351.   "Narrow window to region between cursor and mouse pointer."
  352.   (interactive "@e")
  353.   (let ((point-save (point)))
  354.     (unwind-protect
  355.     (progn (mouse-set-point event)
  356.            (push-mark nil t)
  357.            (sit-for 1))
  358.       (goto-char point-save)
  359.       (narrow-window-to-region (region-beginning) (region-end)))))
  360.  
  361. (defun mouse-ignore ()
  362.   "Don't do anything."
  363.   (interactive))
  364.  
  365.  
  366. ;;
  367. ;; Commands for the scroll bar.
  368. ;;
  369.  
  370. ;; #### this stuff has never ever been used and should be junked.
  371.  
  372. ;; Vertical bar
  373.  
  374. (defun mouse-scroll-down (nlines)
  375.   "Junk me, please."
  376.   (interactive "@p")
  377.   (scroll-down nlines))
  378.  
  379. (defun mouse-scroll-up (nlines)
  380.   "Junk me, please."
  381.   (interactive "@p")
  382.   (scroll-up nlines))
  383.  
  384. (defun mouse-scroll-down-full ()
  385.   "Junk me, please."
  386.   (interactive "@")
  387.   (scroll-down nil))
  388.  
  389. (defun mouse-scroll-up-full ()
  390.   "Junk me, please."
  391.   (interactive "@")
  392.   (scroll-up nil))
  393.  
  394. (defun mouse-scroll-move-cursor (nlines)
  395.   "Junk me, please."
  396.   (interactive "@p")
  397.   (move-to-window-line nlines))
  398.  
  399. (defun mouse-scroll-absolute (event)
  400.   "Junk me, please."
  401.   (interactive "@e")
  402.   (let* ((position (event-x event))
  403.      (length (event-y event))
  404.      (size (buffer-size))
  405.      (scale-factor (max 1 (/ 8000000 size)))
  406.      (newpos (* (/ (* (/ size scale-factor) position) length)
  407.             scale-factor)))
  408.     (goto-char newpos)
  409.     (recenter '(4))))
  410.  
  411. ;; These scroll while the invoking button is depressed.
  412.  
  413. (defvar scrolled-lines 0)
  414. (defvar scroll-speed 1)
  415.  
  416. (defun incr-scroll-down (event)
  417.   "Junk me, please."
  418.   (interactive "@e")
  419.   (setq scrolled-lines 0)
  420.   (incremental-scroll scroll-speed))
  421.  
  422. (defun incr-scroll-up (event)
  423.   "Junk me, please."
  424.   (interactive "@e")
  425.   (setq scrolled-lines 0)
  426.   (incremental-scroll (- scroll-speed)))
  427.  
  428. (defun incremental-scroll (n)
  429.   "Junk me, please."
  430.   (let ((down t))
  431.     (while down
  432.       (sit-for mouse-track-scroll-delay)
  433.       (cond ((input-pending-p)
  434.          (let ((event (next-command-event)))
  435.            (if (or (button-press-event-p event)
  436.                (button-release-event-p event))
  437.            (setq down nil))
  438.            (dispatch-event event))))
  439.       (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
  440.       (scroll-down n))))
  441.  
  442. (defun incr-scroll-stop (event)
  443.   "Junk me, please."
  444.   (interactive "@e")
  445.   (setq scrolled-lines 0)
  446.   (sleep-for 1))
  447.  
  448.  
  449. (defun mouse-scroll-left (ncolumns)
  450.   "Junk me, please."
  451.   (interactive "@p")
  452.   (scroll-left ncolumns))
  453.  
  454. (defun mouse-scroll-right (ncolumns)
  455.   "Junk me, please."
  456.   (interactive "@p")
  457.   (scroll-right ncolumns))
  458.  
  459. (defun mouse-scroll-left-full ()
  460.   "Junk me, please."
  461.   (interactive "@")
  462.   (scroll-left nil))
  463.  
  464. (defun mouse-scroll-right-full ()
  465.   "Junk me, please."
  466.   (interactive "@")
  467.   (scroll-right nil))
  468.  
  469. (defun mouse-scroll-move-cursor-horizontally (ncolumns)
  470.   "Junk me, please."
  471.   (interactive "@p")
  472.   (move-to-column ncolumns))
  473.  
  474. (defun mouse-scroll-absolute-horizontally (event)
  475.   "Junk me, please."
  476.   (interactive "@e")
  477.   (set-window-hscroll (selected-window) 33))
  478.  
  479.  
  480.  
  481. ;;; mouse/selection tracking
  482. ;;; generalized mouse-track
  483.  
  484. (defvar default-mouse-track-normalize-point-function
  485.   'default-mouse-track-normalize-point
  486.   "Function called to normalize position of point.
  487. Called with two arguments: TYPE depends on the number of times that the
  488. mouse has been clicked and is a member of `default-mouse-track-type-list',
  489. FORWARDP determines the direction in which the point should be moved.")
  490.  
  491. (defvar mouse-track-down-hook nil
  492.   "Function or functions called when the user presses the mouse.
  493. This hook is invoked by `mouse-track'; thus, it will not be called
  494. for any buttons with a different binding.  The functions will be
  495. called with two arguments: the button-press event and a click
  496. count (see `mouse-track-click-hook').
  497.  
  498. If any function returns non-nil, the remaining functions will not be
  499. called.
  500.  
  501. Note that most applications should take action when the mouse is
  502. released, not when it is pressed.'")
  503.  
  504. (defvar mouse-track-drag-hook nil
  505.   "Function or functions called when the user drags the mouse.
  506. This hook is invoked by `mouse-track'; thus, it will not be called
  507. for any buttons with a different binding.  The functions will be
  508. called with three arguments: the mouse-motion event, a click
  509. count (see `mouse-track-click-hook'), and whether the call to
  510. this hook occurred as a result of a drag timeout (see
  511. `mouse-track-scroll-delay').
  512.  
  513. If any function returns non-nil, the remaining functions will not be
  514. called.
  515.  
  516. Note that no calls to this function will be made until the user
  517. initiates a drag (i.e. moves the mouse more than a certain
  518. threshold in either the X or the Y direction, as defined by
  519. `mouse-track-x-threshold' and `mouse-track-y-threshold').
  520.  
  521. See also `mouse-track-drag-up-hook'.")
  522.  
  523. (defvar mouse-track-drag-up-hook nil
  524.   "Function or functions called when the user finishes a drag.
  525. This hook is invoked by `mouse-track'; thus, it will not be called
  526. for any buttons with a different binding.  The functions will be
  527. called with two arguments: the button-press event and a click
  528. count (see `mouse-track-click-hook').
  529.  
  530. If any function returns non-nil, the remaining functions will not be
  531. called.
  532.  
  533. Note that this hook will not be invoked unless the user has
  534. initiated a drag, i.e. moved the mouse more than a certain threshold
  535. (see `mouse-track-drag-hook').  When this function is invoked,
  536. `mouse-track-drag-hook' will have been invoked at least once.
  537.  
  538. See also `mouse-track-click-hook'.")
  539.  
  540. (defvar mouse-track-click-hook nil
  541.   "Function or functions called when the user clicks the mouse.
  542. `Clicking' means pressing and releasing the mouse without having
  543. initiated a drag (i.e. without having moved more than a certain
  544. threshold -- see `mouse-track-drag-hook').
  545.  
  546. This hook is invoked by `mouse-track'; thus, it will not be called
  547. for any buttons with a different binding.  The functions will be
  548. called with two arguments: the button-release event and a click
  549. count, which specifies the number of times that the mouse has been
  550. clicked in a series of clicks, each of which is separated by at most
  551. `mouse-track-multi-click-time'.  This can be used to implement actions
  552. that are called on double clicks, triple clicks, etc.
  553.  
  554. If any function returns non-nil, the remaining functions will not be
  555. called.
  556.  
  557. See also `mouse-track-drag-up-hook.")
  558.  
  559. (defvar mouse-track-up-hook nil
  560.   "Function or functions called when the user releases the mouse.
  561. This hook is invoked by `mouse-track'; thus, it will not be called
  562. for any buttons with a different binding.  The functions will be
  563. called with two arguments: the button-release event and a click
  564. count (see `mouse-track-click-hook').
  565.  
  566. For many applications, it is more appropriate to use one or both
  567. of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.")
  568.  
  569. (defvar mouse-track-cleanup-hook nil
  570.   "Function or functions called when `mouse-track' terminates.
  571. This hook will be called in all circumstances, even upon a
  572. non-local exit out of `mouse-track', and so is useful for
  573. doing cleanup work such as removing extents that may have
  574. been created during the operation of `mouse-track'.
  575.  
  576. Unlike all of the other mouse-track hooks, this is a \"normal\"
  577. hook: the hook functions are called with no arguments, and
  578. all hook functions are called regardless of their return
  579. values.")
  580.  
  581. (defcustom mouse-track-multi-click-time 400
  582.   "*Maximum number of milliseconds allowed between clicks for a multi-click.
  583. See `mouse-track-click-hook'."
  584.   :type 'integer
  585.   :group 'mouse)
  586.  
  587. (defcustom mouse-track-scroll-delay 100
  588.   "Maximum of milliseconds between calls to `mouse-track-drag-hook'.
  589. If the user is dragging the mouse (i.e. the button is held down and
  590. a drag has been initiated) and does not move the mouse for this many
  591. milliseconds, the hook will be called with t as the value of the
  592. WAS-TIMEOUT parameter.  This can be used to implement scrolling
  593. in a selection when the user drags the mouse out the window it
  594. was in.
  595.  
  596. A value of nil disables the timeout feature."
  597.   :type '(choice integer (const :tag "Disabled" nil))
  598.   :group 'mouse)
  599.  
  600. (defvar mouse-track-x-threshold '(face-width 'default)
  601.   "Minimum number of pixels in the X direction for a drag to be initiated.
  602. If the mouse is moved more than either the X or Y threshold while the
  603. button is held down (see also `mouse-track-y-threshold'), then a drag
  604. is initiated; otherwise the gesture is considered to be a click.
  605. See `mouse-track'.
  606.  
  607. The value should be either a number of a form to be evaluated to
  608. produce a number.")
  609.  
  610. (defvar mouse-track-y-threshold '(face-height 'default)
  611.   "Minimum number of pixels in the Y direction for a drag to be initiated.
  612. If the mouse is moved more than either the X or Y threshold while the
  613. button is held down (see also `mouse-track-x-threshold'), then a drag
  614. is initiated; otherwise the gesture is considered to be a click.
  615. See `mouse-track'.
  616.  
  617. The value should be either a number of a form to be evaluated to
  618. produce a number.")
  619.  
  620. ;; these variables are private to mouse-track.
  621. (defvar mouse-track-up-time nil)
  622. (defvar mouse-track-up-x nil)
  623. (defvar mouse-track-up-y nil)
  624. (defvar mouse-track-timeout-id nil)
  625. (defvar mouse-track-click-count nil)
  626.  
  627. (defun mouse-track-set-timeout (event)
  628.   (if mouse-track-timeout-id
  629.       (disable-timeout mouse-track-timeout-id))
  630.   (if mouse-track-scroll-delay
  631.       (setq mouse-track-timeout-id
  632.         (add-timeout (/ mouse-track-scroll-delay 1000.0)
  633.              'mouse-track-scroll-undefined
  634.              (copy-event event)))))
  635.  
  636. (defun mouse-track-run-hook (hook event &rest args)
  637.   ;; ugh, can't use run-special-hook-with-args because we
  638.   ;; have to get the value using symbol-value-in-buffer.
  639.   ;; Doing a save-excursion/set-buffer is wrong because
  640.   ;; the hook might want to change the buffer, but just
  641.   ;; doing a set-buffer is wrong because the hook might
  642.   ;; not want to change the buffer.
  643.   (let ((buffer (event-buffer event)))
  644.     (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
  645.     (if buffer
  646.     (let ((value (symbol-value-in-buffer hook buffer nil)))
  647.       (if (and (listp value) (not (eq (car value) 'lambda)))
  648.           (let (retval)
  649.         (while (and value
  650.                 (not (setq retval (apply (car value) event args))))
  651.           (setq value (cdr value)))
  652.         retval)
  653.         (apply value event args))))))
  654.  
  655. (defun mouse-track-scroll-undefined (random)
  656.   ;; the old implementation didn't actually define this function,
  657.   ;; and in normal use it won't ever be called because the timeout
  658.   ;; will either be removed before it fires or will be picked off
  659.   ;; with next-event and not dispatched.  However, if you're
  660.   ;; attempting to debug a click-hook (which is pretty damn
  661.   ;; difficult to do), this function may get called.
  662. )
  663.  
  664. (defun mouse-track (event)
  665.   "Make a selection with the mouse.  This should be bound to a mouse button.
  666. The behavior of XEmacs during mouse selection is customizable using various
  667. hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
  668. `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
  669. `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
  670. `mouse-track-scroll-delay', `mouse-track-x-threshold', and
  671. `mouse-track-y-threshold'.
  672.  
  673. Default handlers are provided to implement standard selecting/positioning
  674. behavior.  You can explicitly request this default behavior, and override
  675. any custom-supplied handlers, by using the function `mouse-track-default'
  676. instead of `mouse-track'.
  677.  
  678. Default behavior is as follows: 
  679.  
  680. If you click-and-drag, the selection will be set to the region between the
  681. point of the initial click and the point at which you release the button.
  682. These positions need not be ordered.
  683.  
  684. If you click-and-release without moving the mouse, then the point is moved
  685. and the selection is disowned (there will be no selection owner).  The mark
  686. will be set to the previous position of point.
  687.  
  688. If you double-click, the selection will extend by symbols instead of by
  689. characters.  If you triple-click, the selection will extend by lines.
  690.  
  691. If you drag the mouse off the top or bottom of the window, you can select
  692. pieces of text which are larger than the visible part of the buffer; the
  693. buffer will scroll as necessary.
  694.  
  695. The selected text becomes the current X Selection.  The point will be left
  696. at the position at which you released the button, and the mark will be left
  697. at the initial click position."
  698.   (interactive "e")
  699.   (let ((mouse-down t)
  700.     (xthresh (eval mouse-track-x-threshold))
  701.     (ythresh (eval mouse-track-y-threshold))
  702.     (orig-x (event-x-pixel event))
  703.     (orig-y (event-y-pixel event))
  704.     (buffer (event-buffer event))
  705.     (mouse-grabbed-buffer (event-buffer event))
  706.     mouse-moved)
  707.     (if (or (not mouse-track-up-x)
  708.         (not mouse-track-up-y)
  709.         (not mouse-track-up-time)
  710.         (> (- (event-timestamp event) mouse-track-up-time)
  711.            mouse-track-multi-click-time)
  712.         (> (abs (- mouse-track-up-x orig-x)) xthresh)
  713.         (> (abs (- mouse-track-up-y orig-y)) ythresh))
  714.     (setq mouse-track-click-count 1)
  715.       (setq mouse-track-click-count (1+ mouse-track-click-count)))
  716.     (if (not (event-window event))
  717.     (error "Not over a window."))
  718.     (mouse-track-run-hook 'mouse-track-down-hook
  719.               event mouse-track-click-count)
  720.     (unwind-protect
  721.     (while mouse-down
  722.       (setq event (next-event event))
  723.       (cond ((motion-event-p event)
  724.          (if (and (not mouse-moved)
  725.               (or (> (abs (- (event-x-pixel event) orig-x))
  726.                  xthresh)
  727.                   (> (abs (- (event-y-pixel event) orig-y))
  728.                  ythresh)))
  729.              (setq mouse-moved t))
  730.          (if mouse-moved
  731.              (mouse-track-run-hook 'mouse-track-drag-hook
  732.               event mouse-track-click-count nil))
  733.          (mouse-track-set-timeout event))
  734.         ((and (timeout-event-p event)
  735.               (eq (event-function event)
  736.               'mouse-track-scroll-undefined))
  737.          (if mouse-moved
  738.              (mouse-track-run-hook 'mouse-track-drag-hook
  739.               (event-object event) mouse-track-click-count t))
  740.          (mouse-track-set-timeout (event-object event)))
  741.         ((button-release-event-p event)
  742.          (setq mouse-track-up-time (event-timestamp event))
  743.          (setq mouse-track-up-x (event-x-pixel event))
  744.          (setq mouse-track-up-y (event-y-pixel event))
  745.          (setq mouse-down nil)
  746.          (mouse-track-run-hook 'mouse-track-up-hook
  747.           event mouse-track-click-count)
  748.          (if mouse-moved
  749.              (mouse-track-run-hook 'mouse-track-drag-up-hook
  750.               event mouse-track-click-count)
  751.            (mouse-track-run-hook 'mouse-track-click-hook
  752.             event mouse-track-click-count)))
  753.         ((key-press-event-p event)
  754.          (error "Selection aborted"))
  755.         (t
  756.          (dispatch-event event))))
  757.       ;; protected
  758.       (if mouse-track-timeout-id
  759.       (disable-timeout mouse-track-timeout-id))
  760.       (setq mouse-track-timeout-id nil)
  761.       (and buffer
  762.        (save-excursion
  763.          (set-buffer buffer)
  764.          (run-hooks 'mouse-track-cleanup-hook))))))
  765.  
  766.  
  767. ;;;;;;;;;;;; default handlers: new version of mouse-track
  768.  
  769. (defvar default-mouse-track-type nil)
  770. (defvar default-mouse-track-type-list '(char word line))
  771. (defvar default-mouse-track-window nil)
  772. (defvar default-mouse-track-extent nil)
  773. (defvar default-mouse-track-adjust nil)
  774. (defvar default-mouse-track-min-anchor nil)
  775. (defvar default-mouse-track-max-anchor nil)
  776. (defvar default-mouse-track-result nil)
  777. (defvar default-mouse-track-down-event nil)
  778.  
  779. ;; D. Verna Feb. 17 1998
  780. ;; This function used to assume that when (event-window event) differs from 
  781. ;; window, we have to scroll. This is WRONG, for instance when there are
  782. ;; toolbars on the side, in which case window-event returns nil.
  783. (defun default-mouse-track-set-point-in-window (event window)
  784.   (if (event-over-modeline-p event)
  785.       nil ;; Scroll
  786.     ;; Not over a modeline
  787.     (if (eq (event-window event) window)
  788.     (let ((p (event-closest-point event)))
  789.       (if  (or (not p) (not (pos-visible-in-window-p p window)))
  790.           nil ;; Scroll
  791.         (mouse-set-point event)
  792.         t))
  793.       ;; Not over a modeline, not the same window. Check if the Y position
  794.       ;; is still overlapping the original window. 
  795.       (let* ((edges (window-pixel-edges window))
  796.          (row (event-y-pixel event))
  797.          (text-start (nth 1 edges))
  798.          (text-end (+ (nth 3 edges))))
  799.     (if (or (< row text-start) 
  800.         (> row text-end))
  801.         nil ;; Scroll
  802.       ;; The Y pos in overlapping the original window. Check however if
  803.       ;; the position is really visible, because there could be a 
  804.       ;; scrollbar or a modeline at this place.
  805.       ;; Find the mean line height (height / lines nb), and approximate
  806.       ;; the line number for Y pos.
  807.       (select-window window)
  808.       (let ((line (/ (* (- row text-start) (window-height)) 
  809.              (- text-end text-start))))
  810.         (if (not (save-excursion
  811.                (goto-char (window-start))
  812.                (pos-visible-in-window-p
  813.             (point-at-bol (+ 1 line)))))
  814.         nil ;; Scroll
  815.           ;; OK, we can go to that position
  816.           (goto-char (window-start))
  817.           (forward-line line)
  818.           ;; On the right side: go to end-of-line.
  819.           (when (>= (event-x-pixel event) (nth 2 edges))
  820.         (goto-char (point-at-eol)))
  821.           t))))
  822.       )))
  823.  
  824.  
  825. (defun default-mouse-track-scroll-and-set-point (event window)
  826.   (select-window window)
  827.   (let ((edges (window-pixel-edges window))
  828.     (row (event-y-pixel event))
  829.     (height (face-height 'default)))
  830.     (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges))))
  831.        ;; closer to window's top than to bottom, so move up
  832.        (let ((delta (max 1 (/ (- (nth 1 edges) row) height))))
  833.          (condition-case () (scroll-down delta) (error))
  834.          (goto-char (window-start))))
  835.       ((>= (point) (point-max)))
  836.       (t
  837.        ;; scroll by one line if over the modeline or a clipped line
  838.        (let ((delta (if (or (event-over-modeline-p event)
  839.                 (< row (nth 3 edges)))
  840.                 1
  841.               (+ (/ (- row (nth 3 edges)) height) 1)))
  842.          (close-pos (event-closest-point event)))
  843.          (condition-case () (scroll-up delta) (error))
  844.          (if (and close-pos (pos-visible-in-window-p close-pos))
  845.          (goto-char close-pos)
  846.            (goto-char (window-end))
  847.            (vertical-motion delta)
  848.            ;; window-end reports the end of the clipped line, even if
  849.            ;; scroll-on-clipped-lines is t.  compensate.
  850.            ;; (If window-end gets fixed this can be removed.)
  851.            (if (not (pos-visible-in-window-p (max (1- (point)) 
  852.                               (point-min))))
  853.            (vertical-motion -1))
  854.            (condition-case () (backward-char 1) 
  855.          (error (end-of-line)))))))))
  856.  
  857.  
  858. ;; This remembers the last position at which the user clicked, for the
  859. ;; benefit of mouse-track-adjust (for example, button1; scroll until the
  860. ;; position of the click is off the frame; then Sh-button1 to select the
  861. ;; new region.
  862. (defvar default-mouse-track-previous-point nil)
  863.  
  864. (defun default-mouse-track-set-point (event window)
  865.   (if (default-mouse-track-set-point-in-window event window)
  866.       nil
  867.     (default-mouse-track-scroll-and-set-point event window)))
  868.  
  869. (defsubst default-mouse-track-beginning-of-word (symbolp)
  870.   (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
  871.                 ((null symbolp) "\\w")
  872.                 (t "[^ \t\n]")))
  873.     (white-space "[ \t]"))
  874.     (cond ((bobp) nil)
  875.       ((looking-at word-constituent)
  876.        (backward-char)
  877.        (while (and (not (bobp)) (looking-at word-constituent))
  878.          (backward-char))
  879.        (if (or (not (bobp)) (not (looking-at word-constituent)))
  880.            (forward-char)))
  881.       ((looking-at white-space)
  882.        (backward-char)
  883.        (while (looking-at white-space)
  884.          (backward-char))
  885.        (forward-char)))))
  886.  
  887. (defun default-mouse-track-end-of-word (symbolp)
  888.   (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
  889.                 ((null symbolp) "\\w")
  890.                 (t "[^ \t\n]")))
  891.     (white-space "[ \t]"))
  892.     (cond ((looking-at word-constituent) ; word or symbol constituent
  893.        (while (looking-at word-constituent)
  894.          (forward-char)))
  895.       ((looking-at white-space) ; word or symbol constituent
  896.        (while (looking-at white-space)
  897.          (forward-char))))))
  898.  
  899. (defun default-mouse-track-normalize-point (type forwardp)
  900.   (cond ((eq type 'word)
  901.      ;; trap the beginning and end of buffer errors
  902.      (condition-case ()
  903.          (progn
  904.            (setq type (char-syntax (char-after (point))))
  905.            (if forwardp
  906.            (if (= type ?\()
  907.                (goto-char (scan-sexps (point) 1))
  908.              (if (= type  ?\))
  909.              (forward-char 1)
  910.                (default-mouse-track-end-of-word t)))
  911.          (if (= type ?\))
  912.              (goto-char (scan-sexps (1+ (point)) -1))
  913.            (default-mouse-track-beginning-of-word t))))
  914.        (error ())))
  915.     ((eq type 'line)
  916.      (if forwardp (end-of-line) (beginning-of-line)))
  917.     ((eq type 'buffer)
  918.      (if forwardp (end-of-buffer) (beginning-of-buffer)))))
  919.  
  920. (defun default-mouse-track-next-move (min-anchor max-anchor extent)
  921.   (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor)))
  922.     (funcall default-mouse-track-normalize-point-function
  923.          default-mouse-track-type (> (point) anchor))
  924.     (if (consp extent)
  925.     (default-mouse-track-next-move-rect anchor (point) extent)
  926.       (if extent
  927.       (if (<= anchor (point))
  928.           (set-extent-endpoints extent anchor (point))
  929.         (set-extent-endpoints extent (point) anchor))))))
  930.  
  931. (defun default-mouse-track-next-move-rect (start end extents &optional pad-p)
  932.   (if (< end start)
  933.       (let ((tmp start)) (setq start end end tmp)))
  934.   (cond
  935.    ((= start end)        ; never delete the last remaining extent
  936.     (mapcar 'delete-extent (cdr extents))
  937.     (setcdr extents nil)
  938.     (set-extent-endpoints (car extents) start start))
  939.    (t
  940.     (let ((indent-tabs-mode nil)    ; if pad-p, don't use tabs
  941.       (rest extents)
  942.       left right last p)
  943.       (save-excursion
  944.     (save-restriction
  945.       (goto-char end)
  946.       (setq right (current-column))
  947.       (goto-char start)
  948.       (setq left (current-column))
  949.       (if (< right left)
  950.           (let ((tmp left))
  951.         (setq left right right tmp)
  952.         (setq start (- start (- right left))
  953.               end (+ end (- right left)))))
  954.       ;; End may have been set to a value greater than point-max if drag
  955.       ;; or movement extends to end of buffer, so reset it.
  956.       (setq end (min end (point-max)))
  957.       (beginning-of-line)
  958.       (narrow-to-region (point) end)
  959.       (goto-char start)
  960.       (while (and rest (not (eobp)))
  961.         (setq p (point))
  962.         (move-to-column right pad-p)
  963.         (set-extent-endpoints (car rest) p (point))
  964.         ;; this code used to look at the return value
  965.         ;; of forward-line, but that doesn't work because
  966.         ;; forward-line has bogus behavior: If you're on
  967.         ;; the last line of a buffer but not at the very
  968.         ;; end, forward-line will move you to the very
  969.         ;; end and return 0 instead of 1, like it should.
  970.         ;; the result was frequent infinite loops here,
  971.         ;; creating very large numbers of extents at
  972.         ;; the same position.  There was an N^2 sorting
  973.         ;; algorithm in extents.c for extents at a
  974.         ;; particular position, and the result was very
  975.         ;; bad news.
  976.         (forward-line 1)
  977.         (if (not (eobp))
  978.         (move-to-column left pad-p))
  979.         (setq last rest
  980.           rest (cdr rest)))
  981.       (cond (rest
  982.          (mapcar 'delete-extent rest)
  983.          (setcdr last nil))
  984.         ((not (eobp))
  985.          (while (not (eobp))
  986.            (setq p (point))
  987.            (move-to-column right pad-p)
  988.            (let ((e (make-extent p (point))))
  989.              (set-extent-face e (extent-face (car extents)))
  990.              (set-extent-priority e (extent-priority (car extents)))
  991.              (setcdr last (cons e nil))
  992.              (setq last (cdr last)))
  993.            (forward-line 1)
  994.            (if (not (eobp))
  995.                (move-to-column left pad-p))
  996.            )))))
  997.       ))))
  998.  
  999. (defun default-mouse-track-has-selection-p (buffer)
  1000.   (and (or (not (eq 'x (console-type (selected-console))))
  1001.        (x-selection-owner-p))
  1002.        (extent-live-p primary-selection-extent)
  1003.        (not (extent-detached-p primary-selection-extent))
  1004.        (eq buffer (extent-object primary-selection-extent))))
  1005.  
  1006. (defun default-mouse-track-anchor (adjust previous-point)
  1007.   (if adjust
  1008.       (if (default-mouse-track-has-selection-p (current-buffer))
  1009.       (let ((start (extent-start-position primary-selection-extent))
  1010.         (end (extent-end-position primary-selection-extent)))
  1011.         (cond ((< (point) start) end)
  1012.           ((> (point) end) start)
  1013.           ((> (- (point) start) (- end (point))) start)
  1014.           (t end)))
  1015.     previous-point)
  1016.     (point)))
  1017.  
  1018. (defun default-mouse-track-maybe-own-selection (pair type)
  1019.   (let ((start (car pair))
  1020.     (end (cdr pair)))
  1021.     (or (= start end) (push-mark (if (= (point) start) end start)))
  1022.     (cond (zmacs-regions
  1023.        (if (= start end)
  1024.            nil
  1025.          ;; #### UTTER KLUDGE.
  1026.          ;; If we don't have this sit-for here, then triple-clicking
  1027.          ;; will result in the line not being highlighted as it
  1028.          ;; should.  What appears to be happening is this:
  1029.          ;;
  1030.          ;; -- each time the button goes down, the selection is
  1031.          ;;    disowned (see comment "remove the existing selection
  1032.          ;;    to unclutter the display", below).
  1033.          ;; -- this causes a SelectionClear event to be sent to
  1034.          ;;    XEmacs.
  1035.          ;; -- each time the button goes up except the first, the
  1036.          ;;    selection is owned again.
  1037.          ;; -- later, XEmacs processes the SelectionClear event.
  1038.          ;;    The selection code attempts to keep track of the
  1039.          ;;    time that it last asserted the selection, and
  1040.          ;;    compare it to the time of the SelectionClear event,
  1041.          ;;    to see if it's a bogus notification or not (as
  1042.          ;;    is the case here).  However, for some unknown
  1043.          ;;    reason this doesn't work in the triple-clicking
  1044.          ;;    case, and the selection code bogusly thinks this
  1045.          ;;    SelectionClear event is the real thing.
  1046.          ;; -- putting the sit-for in causes the pending
  1047.          ;;    SelectionClear events to get processed before
  1048.          ;;    the selection is reasserted, so everything works
  1049.          ;;    out OK.
  1050.          ;;
  1051.          ;; Presumably(?) this means there is a weird timing bug
  1052.          ;; in the selection code, but there's not a chance in hell
  1053.          ;; that I have the patience to track it down.  Blame the
  1054.          ;; designers of X for fucking everything up so badly.
  1055.          ;;
  1056.          ;; This was originally a sit-for 0 but that wasn't
  1057.          ;; sufficient to make things work.  Even this isn't
  1058.          ;; always sufficient but it seems to give something
  1059.          ;; approaching a 99% success rate.  Making it higher yet
  1060.          ;; would help guarantee success with the price that the
  1061.          ;; delay would start to become noticable.
  1062.          ;;
  1063.          (sit-for 0.15 t)
  1064.          (zmacs-activate-region)))
  1065.       ((eq 'x (console-type (selected-console)))
  1066.        (if (= start end)
  1067.            (x-disown-selection type)
  1068.          (if (consp default-mouse-track-extent)
  1069.          ;; own the rectangular region
  1070.          ;; this is a hack
  1071.          (let ((r default-mouse-track-extent))
  1072.            (save-excursion
  1073.              (set-buffer (get-buffer-create " *rect yank temp buf*"))
  1074.              (while r
  1075.                (insert (extent-string (car r)) "\n")
  1076.                (setq r (cdr r)))
  1077.              (x-own-selection (buffer-substring (point-min) (point-max)))
  1078.              (kill-buffer (current-buffer))))
  1079.            (x-own-selection (cons (set-marker (make-marker) start)
  1080.                       (set-marker (make-marker) end))
  1081.                 type)))))
  1082.     (if (and (eq 'x (console-type (selected-console)))
  1083.          (not (= start end)))
  1084.     ;; I guess cutbuffers should do something with rectangles too.
  1085.     ;; does anybody use them?
  1086.     (x-store-cutbuffer (buffer-substring start end)))))
  1087.  
  1088. (defun default-mouse-track-deal-with-down-event (click-count)
  1089.   (let ((event default-mouse-track-down-event))
  1090.     (if (null event) nil
  1091.       (select-frame (event-frame event))
  1092.       (let ((adjust default-mouse-track-adjust)
  1093.         ;; ####When you click on the splash-screen,
  1094.         ;; event-{closest-,}point can be out of bounds.  Should
  1095.         ;; event-closest-point really be allowed to return a bad
  1096.         ;; position like that?  Maybe pixel_to_glyph_translation
  1097.         ;; needs to invalidate its cache when the buffer changes.
  1098.         ;; -dkindred@cs.cmu.edu
  1099.         (close-pos  (save-excursion
  1100.               (set-buffer (event-buffer event))
  1101.               (let ((p (event-closest-point event)))
  1102.                 (and p (min (max p (point-min)) (point-max))))))
  1103.         extent previous-point)
  1104.     
  1105.     (if (not (event-window event))
  1106.         (error "not over window?"))
  1107.     (setq default-mouse-track-type
  1108.           (nth (mod (1- click-count)
  1109.             (length default-mouse-track-type-list))
  1110.            default-mouse-track-type-list))
  1111.     (setq default-mouse-track-window (event-window event))
  1112.     ;; Note that the extent used here is NOT the extent which
  1113.     ;; ends up as the value of zmacs-region-extent - this one is used
  1114.     ;; just during mouse-dragging.
  1115.     (setq default-mouse-track-extent
  1116.           (make-extent close-pos close-pos (event-buffer event)))
  1117.     (setq extent default-mouse-track-extent)
  1118.     (set-extent-face extent 'zmacs-region)
  1119.     ;; While the selection is being dragged out, give the selection extent
  1120.     ;; slightly higher priority than any mouse-highlighted extent, so that
  1121.     ;; the exact endpoints of the selection will be visible while the mouse
  1122.     ;; is down.  Normally, the selection and mouse highlighting have the
  1123.     ;; same priority, so that conflicts between the two of them are
  1124.     ;; resolved by the usual size-and-endpoint-comparison method.
  1125.     (set-extent-priority extent (1+ mouse-highlight-priority))
  1126.     (if mouse-track-rectangle-p
  1127.         (setq default-mouse-track-extent
  1128.           (list default-mouse-track-extent)))
  1129.     
  1130.     (setq previous-point
  1131.           (if (and adjust
  1132.                (markerp default-mouse-track-previous-point)
  1133.                (eq (current-buffer)
  1134.                (marker-buffer default-mouse-track-previous-point)))
  1135.           (marker-position default-mouse-track-previous-point)
  1136.         (point)))
  1137.     (default-mouse-track-set-point event default-mouse-track-window)
  1138.     (if (not adjust)
  1139.         (if (markerp default-mouse-track-previous-point)
  1140.         (set-marker default-mouse-track-previous-point (point))
  1141.           (setq default-mouse-track-previous-point (point-marker))))
  1142.     ;;
  1143.     ;; adjust point to a word or line boundary if appropriate
  1144.     (let ((anchor (default-mouse-track-anchor adjust previous-point)))
  1145.       (setq default-mouse-track-min-anchor
  1146.         (save-excursion (goto-char anchor)
  1147.                 (funcall
  1148.                  default-mouse-track-normalize-point-function
  1149.                  default-mouse-track-type nil)
  1150.                 (point)))
  1151.       (setq default-mouse-track-max-anchor
  1152.         (save-excursion (goto-char anchor)
  1153.                 (funcall
  1154.                  default-mouse-track-normalize-point-function
  1155.                  default-mouse-track-type t)
  1156.                 (point))))
  1157.     ;;
  1158.     ;; remove the existing selection to unclutter the display
  1159.     (if (not adjust)
  1160.         (cond (zmacs-regions
  1161.            (zmacs-deactivate-region))
  1162.           ((eq 'x (console-type (selected-console)))
  1163.            (x-disown-selection)))))
  1164.       (setq default-mouse-track-down-event nil))))
  1165.  
  1166. (defun default-mouse-track-down-hook (event click-count)
  1167.   (setq default-mouse-track-down-event (copy-event event))
  1168.   nil)
  1169.  
  1170. (defun default-mouse-track-cleanup-extents-hook ()
  1171.   (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
  1172.   (let ((extent default-mouse-track-extent))
  1173.     (if (consp extent) ; rectangle-p
  1174.     (mapcar 'delete-extent extent)
  1175.       (if extent
  1176.       (delete-extent extent)))))
  1177.  
  1178. (defun default-mouse-track-cleanup-hook ()
  1179.   (if zmacs-regions
  1180.       (funcall 'default-mouse-track-cleanup-extents-hook)
  1181.     (let ((extent default-mouse-track-extent)
  1182.       (func #'(lambda (e)
  1183.             (and (extent-live-p e)
  1184.              (set-extent-face e 'primary-selection)))))
  1185.       (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
  1186.       (if (consp extent)        ; rectangle-p
  1187.       (mapcar func extent)
  1188.     (if extent
  1189.         (funcall func extent))))))
  1190.  
  1191. (defun default-mouse-track-cleanup-extent ()
  1192.   (let ((dead-func
  1193.      (function (lambda (x)
  1194.              (or (not (extent-live-p x))
  1195.              (extent-detached-p x)))))
  1196.     (extent default-mouse-track-extent))
  1197.     (if (consp extent)
  1198.     (if (funcall dead-func extent)
  1199.         (let (newval)
  1200.           (mapcar (function (lambda (x)
  1201.                   (if (not (funcall dead-func x))
  1202.                       (setq newval (cons x newval)))))
  1203.               extent)
  1204.           (setq default-mouse-track-extent (nreverse newval))))
  1205.       (if (funcall dead-func extent)
  1206.       (setq default-mouse-track-extent nil)))))
  1207.  
  1208. (defun default-mouse-track-drag-hook (event click-count was-timeout)
  1209.   (default-mouse-track-deal-with-down-event click-count)
  1210.   (default-mouse-track-set-point event default-mouse-track-window)
  1211.   (default-mouse-track-cleanup-extent)
  1212.   (default-mouse-track-next-move default-mouse-track-min-anchor
  1213.     default-mouse-track-max-anchor
  1214.     default-mouse-track-extent)
  1215.   t)
  1216.  
  1217. (defun default-mouse-track-return-dragged-selection (event)
  1218.   (default-mouse-track-cleanup-extent)
  1219.   (let ((extent default-mouse-track-extent)
  1220.     result)
  1221.     (default-mouse-track-set-point-in-window event default-mouse-track-window)
  1222.     (default-mouse-track-next-move default-mouse-track-min-anchor
  1223.                default-mouse-track-max-anchor
  1224.                extent)
  1225.     (cond ((consp extent) ; rectangle-p
  1226.        (let ((first (car extent))
  1227.          (last (car (setq extent (nreverse extent)))))
  1228.          ;; nreverse is destructive so we need to reset this
  1229.          (setq default-mouse-track-extent extent)
  1230.          (setq result (cons (extent-start-position first)
  1231.                 (extent-end-position last)))
  1232.          ;; kludge to fix up region when dragging backwards...
  1233.          (if (and (/= (point) (extent-start-position first))
  1234.               (/= (point) (extent-end-position last))
  1235.               (= (point) (extent-end-position first)))
  1236.          (goto-char (car result)))))
  1237.       (extent
  1238.        (setq result (cons (extent-start-position extent)
  1239.                   (extent-end-position extent)))))
  1240.     ;; Minor kludge: if we're selecting in line-mode, include the
  1241.     ;; final newline.  It's hard to do this in *-normalize-point.
  1242.     (if (and result (eq default-mouse-track-type 'line))
  1243.     (let ((end-p (= (point) (cdr result))))
  1244.       (goto-char (cdr result))
  1245.       (if (not (eobp))
  1246.           (setcdr result (1+ (cdr result))))
  1247.       (goto-char (if end-p (cdr result) (car result)))))
  1248. ;;;      ;; Minor kludge sub 2.  If in char mode, and we drag the
  1249. ;;;      ;; mouse past EOL, include the newline.
  1250. ;;;      ;;
  1251. ;;;      ;; Major problem: can't easily distinguish between being
  1252. ;;;      ;; just past the last char on a line, and well past it,
  1253. ;;;      ;; to determine whether or not to include it in the region
  1254. ;;;      ;;
  1255. ;;;      (if nil ; (eq default-mouse-track-type 'char)
  1256. ;;;          (let ((after-end-p (and (not (eobp))
  1257. ;;;                       (eolp)
  1258. ;;;                      (> (point) (car result)))))
  1259. ;;;        (if after-end-p
  1260. ;;;            (progn
  1261. ;;;              (setcdr result (1+ (cdr result)))
  1262. ;;;              (goto-char (cdr result))))))
  1263.     result))
  1264.  
  1265. (defun default-mouse-track-drag-up-hook (event click-count)
  1266.   (let ((result (default-mouse-track-return-dragged-selection event)))
  1267.     (if result
  1268.     (default-mouse-track-maybe-own-selection result 'PRIMARY)))
  1269.   t)
  1270.  
  1271. (defun default-mouse-track-click-hook (event click-count)
  1272.   (default-mouse-track-drag-hook event click-count nil)
  1273.   (default-mouse-track-drag-up-hook event click-count)
  1274.   t)
  1275.  
  1276. (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
  1277. (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
  1278. (add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
  1279. (add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook)
  1280. (add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)
  1281.  
  1282.  
  1283. ;;;;;;;;;;;; other mouse-track stuff (mostly associated with the
  1284. ;;;;;;;;;;;; default handlers)
  1285.  
  1286. (defun mouse-track-default (event)
  1287.   "Invoke `mouse-track' with only the default handlers active."
  1288.   (interactive "e")
  1289.   (let ((mouse-track-down-hook 'default-mouse-track-down-hook)
  1290.     (mouse-track-drag-hook 'default-mouse-track-drag-hook)
  1291.     (mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
  1292.     (mouse-track-click-hook 'default-mouse-track-click-hook)
  1293.     (mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook))
  1294.     (mouse-track event)))
  1295.  
  1296. (defun mouse-track-do-rectangle (event)
  1297.   "Like `mouse-track' but selects rectangles instead of regions."
  1298.   (interactive "e")
  1299.   (let ((mouse-track-rectangle-p t))
  1300.     (mouse-track event)))
  1301.  
  1302. (defun mouse-track-adjust (event)
  1303.   "Extend the existing selection.  This should be bound to a mouse button.
  1304. The selection will be enlarged or shrunk so that the point of the mouse
  1305. click is one of its endpoints.  This function in fact behaves fairly
  1306. similarly to `mouse-track', but begins by extending the existing selection
  1307. (or creating a new selection from the previous text cursor position to
  1308. the current mouse position) instead of creating a new, empty selection.
  1309.  
  1310. The mouse-track handlers are run from this command just like from
  1311. `mouse-track'.  Therefore, do not call this command from a mouse-track
  1312. handler!"
  1313.   (interactive "e")
  1314.   (let ((default-mouse-track-adjust t))
  1315.     (mouse-track event)))
  1316.  
  1317. (defun mouse-track-adjust-default (event)
  1318.   "Extend the existing selection, using only the default handlers.
  1319. This is just like `mouse-track-adjust' but will override any
  1320. custom mouse-track handlers that the user may have installed."
  1321.   (interactive "e")
  1322.   (let ((default-mouse-track-adjust t))
  1323.     (mouse-track-default event)))
  1324.  
  1325. (defvar mouse-track-insert-selected-region nil)
  1326.  
  1327. (defun mouse-track-insert-drag-up-hook (event click-count)
  1328.   (setq mouse-track-insert-selected-region
  1329.     (default-mouse-track-return-dragged-selection event)))
  1330.   
  1331. (defun mouse-track-insert (event &optional delete)
  1332.   "Make a selection with the mouse and insert it at point.
  1333. This is exactly the same as the `mouse-track' command on \\[mouse-track],
  1334. except that point is not moved; the selected text is immediately inserted
  1335. after being selected\; and the selection is immediately disowned afterwards."
  1336.   (interactive "*e")
  1337.   (setq mouse-track-insert-selected-region nil)
  1338.   (let ((mouse-track-drag-up-hook 'mouse-track-insert-drag-up-hook)
  1339.      (mouse-track-click-hook 'mouse-track-insert-click-hook)
  1340.     s)
  1341.     (save-excursion
  1342.       (save-window-excursion
  1343.     (mouse-track event)
  1344.     (if (consp mouse-track-insert-selected-region)
  1345.         (let ((pair mouse-track-insert-selected-region))
  1346.           (setq s (prog1
  1347.               (buffer-substring (car pair) (cdr pair))
  1348.             (if delete
  1349.                 (kill-region (car pair) (cdr pair)))))))))
  1350.     (or (null s) (equal s "") (insert s))))
  1351.  
  1352. (defun mouse-track-insert-click-hook (event click-count)
  1353.   (default-mouse-track-drag-hook event click-count nil)
  1354.   (mouse-track-insert-drag-up-hook event click-count)
  1355.   t)
  1356.  
  1357. (defun mouse-track-delete-and-insert (event)
  1358.   "Make a selection with the mouse and insert it at point.
  1359. This is exactly the same as the `mouse-track' command on \\[mouse-track],
  1360. except that point is not moved; the selected text is immediately inserted
  1361. after being selected\; and the text of the selection is deleted."
  1362.   (interactive "*e")
  1363.   (mouse-track-insert event t))
  1364.  
  1365. ;;;;;;;;;;;;;;;;;;;;;;;;
  1366.  
  1367.  
  1368. (defvar inhibit-help-echo nil
  1369.   "Inhibits display of `help-echo' extent properties in the minibuffer.")
  1370. (defvar last-help-echo-object nil)
  1371. (defvar help-echo-owns-message nil)
  1372.  
  1373. (defun clear-help-echo (&optional ignored-frame)
  1374.   (if help-echo-owns-message
  1375.       (progn
  1376.     (setq help-echo-owns-message nil
  1377.           last-help-echo-object nil)
  1378.     (clear-message 'help-echo))))
  1379.  
  1380. (defun show-help-echo (mess)
  1381.   ;; (clear-help-echo)
  1382.   (setq help-echo-owns-message t)
  1383.   (display-message 'help-echo mess))
  1384.  
  1385. (add-hook 'mouse-leave-frame-hook 'clear-help-echo)
  1386.  
  1387. (defun default-mouse-motion-handler (event)
  1388.   "For use as the value of `mouse-motion-handler'.
  1389. This implements the various pointer-shape variables,
  1390. as well as extent highlighting, help-echo, toolbar up/down,
  1391. and `mode-motion-hook'."
  1392.   (let* ((frame (or (event-frame event) (selected-frame)))
  1393.      (window (event-window event))
  1394.      (buffer (event-buffer event))
  1395.      (point (and buffer (event-point event)))
  1396.      (modeline-point (and buffer (event-modeline-position event)))
  1397.      (extent (and point (extent-at point buffer 'mouse-face)))
  1398.      (glyph1 (event-glyph-extent event))
  1399.      (glyph (and glyph1 (extent-live-p glyph1) glyph1))
  1400.      (user-pointer1 (or (and glyph (extent-property glyph 'pointer))
  1401.                 (and point
  1402.                  (condition-case nil
  1403.                      (extent-at point buffer 'pointer)
  1404.                    (error nil)))
  1405.                 (and modeline-point
  1406.                  (condition-case nil
  1407.                      (extent-at modeline-point
  1408.                         (symbol-value-in-buffer
  1409.                          'generated-modeline-string
  1410.                          buffer) 'pointer)))))
  1411.      (user-pointer (and user-pointer1 (extent-live-p user-pointer1)
  1412.                 (extent-property user-pointer1 'pointer)))
  1413.      (button (event-toolbar-button event))
  1414.      (help (or (and glyph (extent-property glyph 'help-echo) glyph)
  1415.            (and button (not (null (toolbar-button-help-string button)))
  1416.             button)
  1417.            (and point
  1418.             (condition-case nil
  1419.                 (extent-at point buffer 'help-echo)
  1420.               (error nil)))
  1421.            (and modeline-point
  1422.             (condition-case nil
  1423.                 (extent-at modeline-point
  1424.                        (symbol-value-in-buffer
  1425.                     'generated-modeline-string
  1426.                     buffer) 'help-echo)))))
  1427.      ;; vars is a list of glyph variables to check for a pointer
  1428.      ;; value.
  1429.      (vars (cond
  1430.         ;; Checking if button is non-nil is not sufficent
  1431.         ;; since the pointer could be over a blank portion
  1432.         ;; of the toolbar.
  1433.         ((event-over-toolbar-p event)
  1434.          '(toolbar-pointer-glyph nontext-pointer-glyph
  1435.                      text-pointer-glyph))
  1436.         ((or extent glyph)
  1437.          '(selection-pointer-glyph text-pointer-glyph))
  1438.         ((event-over-modeline-p event)
  1439.          '(modeline-pointer-glyph nontext-pointer-glyph
  1440.                       text-pointer-glyph))
  1441.         (point '(text-pointer-glyph))
  1442.         (buffer '(nontext-pointer-glyph text-pointer-glyph))
  1443.         (t '(modeline-pointer-glyph nontext-pointer-glyph
  1444.                         text-pointer-glyph))))
  1445.      pointer)
  1446.     (if (and user-pointer (glyphp user-pointer))
  1447.     (setq vars (cons 'user-pointer vars)))
  1448.     (while (and vars (not (pointer-image-instance-p pointer)))
  1449.       (setq pointer (glyph-image-instance (symbol-value (car vars))
  1450.                       (or window frame))
  1451.         vars (cdr vars)))
  1452.  
  1453.     (if (pointer-image-instance-p pointer)
  1454.     (set-frame-pointer frame pointer))
  1455.  
  1456.     ;; If last-pressed-toolbar-button is not nil, then check and see
  1457.     ;; if we have moved to a new button and adjust the down flags
  1458.     ;; accordingly.
  1459.     (if (and (featurep 'toolbar) toolbar-active)
  1460.     (if (not (eq last-pressed-toolbar-button button))
  1461.         (progn
  1462.           (release-previous-toolbar-button event)
  1463.           (and button (press-toolbar-button event)))))
  1464.     
  1465.     (cond (extent (highlight-extent extent t))
  1466.       (glyph (highlight-extent glyph t))
  1467.       (t (highlight-extent nil nil)))
  1468.     (cond ((extentp help)
  1469.            (or inhibit-help-echo
  1470.                (eq help last-help-echo-object) ;save some time
  1471.                (let ((hprop (extent-property help 'help-echo)))
  1472.                  (setq last-help-echo-object help)
  1473.                  (or (stringp hprop)
  1474.                      (setq hprop (funcall hprop help)))
  1475.                  (and hprop (show-help-echo hprop)))))
  1476.       ((and (featurep 'toolbar)
  1477.                 (toolbar-button-p help)
  1478.                 (toolbar-button-enabled-p help))
  1479.        (or (not toolbar-help-enabled)
  1480.            (eq help last-help-echo-object) ;save some time
  1481.            (let ((hstring (toolbar-button-help-string button)))
  1482.          (setq last-help-echo-object help)
  1483.          (or (stringp hstring)
  1484.              (setq hstring (funcall hstring help)))
  1485.          (show-help-echo hstring))))
  1486.           (last-help-echo-object
  1487.        (clear-help-echo)))
  1488.     (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
  1489.     (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil))
  1490.     (save-window-excursion
  1491.       (set-buffer buffer)
  1492.       (run-hook-with-args 'mode-motion-hook event)
  1493.  
  1494.       ;; If the mode-motion-hook created a highlightable extent around
  1495.       ;; the mouse-point, highlight it right away.  Otherwise it wouldn't
  1496.       ;; be highlighted until the *next* motion event came in.
  1497.       (if (and point
  1498.            (null extent)
  1499.            (setq extent (extent-at point
  1500.                        (event-buffer event) ; not buffer
  1501.                        'mouse-face)))
  1502.           (highlight-extent extent t)))))
  1503.   nil)
  1504.  
  1505. (setq mouse-motion-handler 'default-mouse-motion-handler)
  1506.